(* ===================================================================== *)
(** Application bop2vhdl : traduction d'une net-list .bop vers une net-list
    en vhdl, pour permettre ensuite l'utilisation d'outils tiers vers la synthese.
    @author Mathieu Barbin
    @version 1.0.* *)
(* ===================================================================== *)

open Inputtools
open Bop2tools

(** 
    Contrairement à bop2c, bop2vhdl travaille au niveau de la net-list .bop
    uniquement. Les net-list précompilée bpx ne sont pas exploitable.
    
    La raison est d'assurer une certaine cohérence entre les 2 fichiers, 
    en essayant de préserver les identifiants choisis dans le fichier .bop

    On ne fait pas de vérification de contexte dans le fichier .bop lors
    de la traduction. Il est entendu que l'utilisateur peut faire des simulations
    avec bopsimu, avant d'utiliser bop2vhdl.
*)

(* ===================================================================== *)
(** L'implementation du module de transcription qui gere la production de code 
    des structures parsees du fichier bop vers du code vhdl *)
(* ===================================================================== *)
module VhdlTranscriptor : Transcriptor = 
  struct
    let line = String.make 76 '-'

    let init prod bopfile = 
      begin
	prod (line^"\n");
	prod ((center (Printf.sprintf " Circuit original : %s " bopfile) line)^"\n");
	prod ((center (Printf.sprintf " Source vdhl macro-genere par bop2vhdl %s : %s " Message.version (Message.get_date ())) line)^"\n");
	prod (line^"\n");
	prod "\n";
	prod "library IEEE;\n";
	prod "use IEEE.STD_LOGIC_1164.ALL;\n";
	prod "\n";
	prod "\n";
	prod "-- A type for std_logic matrix --\n";
	prod "type std_logic_matrix is array (natural range <>, natural range <>) of std_logic;\n";
      end 

    let of_macros_declaration prod macros_decl = 
      let rec aux = function
	| [] -> ()
	| decl::q -> 
	    begin
	      (
		match decl.corps_macro with
		| DefInt exp ->
		    let const_vhdl = Printf.sprintf "constant %s : integer := %s;\n" decl.nom_macro 
		      (Metatools.unsafe_string_of_expr exp) in
		    prod const_vhdl;
		| DefString s ->
		    let const_vhdl = Printf.sprintf "constant %s : string := \"%s\";\n" decl.nom_macro s in
		    prod const_vhdl;
		| _ -> failwith "TODO ELSE"
	      );
	      aux q 
	    end
      in
      match macros_decl with
      | [] -> ()
      | _ -> 
	  begin
	    prod ((center " #define du circuit original : " line)^"\n");
	    aux macros_decl;
	    prod "\n";
	  end

    let of_memories_declaration prod mems_decl = 
      let f_iter dm =
	let memoryname, name =
	  match dm.type_dcl_m with
	  | RAM_decl name -> (Printf.sprintf "RAM_%s" name), name
	  | ROM_decl name -> (Printf.sprintf "ROM_%s" name), name
	in 
	begin
	  prod "\n";
	  prod (Printf.sprintf "type MOT_%s is std_logic_vector(0 to %s);\n" name (Metatools.unsafe_string_of_expr dm.arite_sortie_dcl_m));
	  prod (Printf.sprintf "type t%s is array (NATURAL range <>) of MOT_%s;\n" memoryname name);
	  prod (Printf.sprintf "type %s is t%s(0 to ((2^%s)-1);\n" memoryname memoryname (Metatools.unsafe_string_of_expr dm.arite_entree_dcl_m));
	  prod (Printf.sprintf "-- Initialisation des memoires de type %s -- \n" memoryname);
	  match dm.description_entree_dcl_m with
	  | None -> prod (Printf.sprintf "-- TODO : INIT ZERO pour toutes les instances de memoire de type %s\n" memoryname);
	  | Some mem_init ->
	      begin
		match mem_init with
		| Text t -> 
		    begin
		      prod (Printf.sprintf "-- TODO : la valeur t suivante est a affecter a toutes les instances de memoire de type %s\n" memoryname);
		      prod (Printf.sprintf "-- TODO : t = \"%s\"\n" t);
		    end
		| File f ->
		    begin
		      prod (Printf.sprintf "-- TODO : le fichier asci suivant est a affecter a toutes les instances de memoire de type %s\n" memoryname);
		      prod (Printf.sprintf "-- TODO : asci file  = \"%s\"\n" f);
		    end
		| BinaryFile bf ->
		    begin
		      prod (Printf.sprintf "-- TODO : le fichier binaire suivant est a affecter a toutes les instances de memoire de type %s\n" memoryname);
		      prod (Printf.sprintf "-- TODO : binary file  = \"%s\"\n" bf);
		    end
		| Counter -> Message.message#counter_for_memory dm.fichier_dcl_m; failwith "w-friendly"
		| UnitFun _ | ArgFun _ -> Message.message#metafun_for_memory dm.fichier_dcl_m; failwith "w-friendly"
	      end
	end
      in 
      match mems_decl with
      | [] -> ()
      | _ ->
	  begin
	    prod ((center " Declaration des memoires RAM et ROM " line)^"\n");
	    List.iter f_iter mems_decl;
	    prod "\n"
	  end

    exception IndexationNotImplemented

    (** Donne le code de l'interface, avec les bons types : TODO optimisation en declaratin en virgule *)
    (* http://comelec.enst.fr/hdl/vhdl_organisation.html#convlex *)
    let of_net_variable_list in_or_out nvl =
      let q_decl = Queue.create () in
      let vhdl_index = function
	| SegmentInit seg -> Printf.sprintf "0 to (%s-1)" (Metatools.unsafe_string_of_expr seg)
	| Intervalle (deb, fin) -> Printf.sprintf "%s to %s" (Metatools.unsafe_string_of_expr deb) (Metatools.unsafe_string_of_expr fin)
	| _ -> raise IndexationNotImplemented
      in
      let rec aux = function 
	| [] -> ()
	| (Simple x)::q ->
	    begin
	      Queue.add (Printf.sprintf "%s : %s std_logic" x in_or_out) q_decl;
	      aux q
	    end
	| (Vecteur (_, x, []))::q -> 
	    begin
	      Queue.add (Printf.sprintf "%s : %s std_logic" x in_or_out) q_decl;
	      aux q
	    end
	| (Vecteur (li, x, [index]))::q ->
	    begin
	      (
		try
		  Queue.add (Printf.sprintf "%s : %s std_logic_vector(%s)" x in_or_out (vhdl_index index)) q_decl;
		with
		| IndexationNotImplemented -> (Message.message#error_indexation_bop2 Message.message#get_net_list li x "bop2vhdl"; failwith "w-friendly") 
	      );
	      aux q
	    end
	| (Vecteur (li, x, [ind1; ind2]))::q ->
	    begin
	      (
		try
		  Queue.add (Printf.sprintf "%s : %s std_logic_matrix(%s, %s)" x in_or_out (vhdl_index ind1) (vhdl_index ind2)) q_decl;
		with
		| IndexationNotImplemented -> (Message.message#error_indexation_bop2 Message.message#get_net_list li x "bop2vhdl"; failwith "w-friendly") 
	      );
	      aux q
	    end
	(* on refuse les autres cas pour l'instant *)
	| (Vecteur (li, x, _))::_ -> (Message.message#error_indexation_bop2 Message.message#get_net_list li x "bop2vhdl"; failwith "w-friendly") 
      in 
      begin
	aux nvl;
	Array.init (Queue.length q_decl) (fun _ -> Queue.pop q_decl)
      end
	    
    let of_fonctions_declaration prod fcts_decl = 
      let prod_decl_entity generics decl =
	prod (Printf.sprintf "entity %s is\n" decl.nom_dcl_f);
	(
	  match generics with
	  | None -> ()
	  | Some sl -> 
	      let rec aux accu = function
		| [] -> accu^");\n"
		| [s] -> (Printf.sprintf "%s%s : natural := 42);\n" accu s)
		| s::q -> aux (Printf.sprintf "%s%s : natural := 42; " accu s) q
	      in prod (aux "  generic(" sl)
	); 
	prod "  port (\n";
	(* ports in *)
	let ports_in = of_net_variable_list "in" decl.entrees_dcl_f in
	let len = Array.length ports_in in 
	for i = 0 to (pred len) do
	  prod ("    "^ports_in.(i)^";\n")
	done;
	(* ports out *)
	let ports_out = of_net_variable_list "out" decl.sorties_dcl_f in
	let len_out = Array.length ports_out in 
	for i = 0 to (len_out - 2) do
	  prod ("    "^ports_out.(i)^";\n")
	done;
	for i = (max 0 (pred len_out)) to (pred len_out) do (* security if len = 0 *)
	  prod ("    "^ports_out.(i)^"\n")
	done;
	prod "  );\n";
	prod "end entity;\n\n"
      in
      let f_iter = function   
	  (* en vhdl, on produit pour chaque fonction une entité, et un bloc *)
	| PARAMETREE (params, decl) -> 
	    begin
	      prod_decl_entity (Some params) decl;   
	    end
	| STANDARD decl ->
	    begin
	      prod_decl_entity None decl;
	    end
      in
      begin 
	prod ((center " Transcription des blocs fonctionnels : " line)^"\n");
	List.iter f_iter fcts_decl
      end
  end
(* ===================================================================== *)

(* ===================================================================== *)
(** Creation du module de Production du code vhdl *)
(* ===================================================================== *)
module VhdlProducer = CodeProducer (VhdlTranscriptor)
(* ===================================================================== *)


let _ = 
  Message.message#thisis "bop2vhdl";
  Message.message#verbose_actif;
  try
    (
      let execution = execution_of_argv Sys.argv in
      match execution.destination with
      | DestStdout    -> 
	  let prod = print_string in
	  VhdlProducer.of_bopfile prod execution.source;
	  flush stdout
      | DestFile file ->
	  let oc = open_out file in
	  let prod = output_string oc in
	  VhdlProducer.of_bopfile prod execution.source;
	  flush oc;
	  close_out oc
    )
  with
  | Arguments_Invalides ->
      Printf.fprintf stderr "use : %s my_file.bop > result.vhdl\n" Sys.argv.(0);
      Printf.fprintf stderr " or : %s my_file.bop -o result.vhdl\n" Sys.argv.(0);
      flush stderr
